home *** CD-ROM | disk | FTP | other *** search
/ Supercompiler 1997 / SUPERCOMPILER97.iso / Delphi 3.0 / DATA.Z / httpapp.pas < prev    next >
Encoding:
Pascal/Delphi Source File  |  1997-01-29  |  49.1 KB  |  1,724 lines
  1. unit HTTPApp;
  2.  
  3. interface
  4.  
  5. uses SyncObjs, SysUtils, Classes, Forms, Masks;
  6.  
  7. const
  8.   DateFormat = 'ddd, dd mmm yyyy hh:mm:ss';
  9.  
  10.   MAX_STRINGS = 13;
  11.   MAX_INTEGERS = 1;
  12.   MAX_DATETIMES = 3;
  13.  
  14. type
  15.   TCharSet = set of Char;
  16.   TMethodType = (mtAny, mtGet, mtPost, mtHead);
  17.  
  18. { TWebRequest }
  19.  
  20.   TWebRequest = class(TObject)
  21.   private
  22.     FMethodType: TMethodType;
  23.     FContentFields,
  24.     FCookieFields,
  25.     FQueryFields: TStrings;
  26.     function GetContentFields: TStrings;
  27.     function GetCookieFields: TStrings;
  28.     function GetQueryFields: TStrings;
  29.   protected
  30.     function GetStringVariable(Index: Integer): string; virtual; abstract;
  31.     function GetDateVariable(Index: Integer): TDateTime; virtual; abstract;
  32.     function GetIntegerVariable(Index: Integer): Integer; virtual; abstract;
  33.   public
  34.     constructor Create;
  35.     destructor Destroy; override;
  36.     // Read count bytes from client
  37.     function ReadClient(var Buffer; Count: Integer): Integer; virtual; abstract;
  38.     // Read count characters as a string from client
  39.     function ReadString(Count: Integer): string; virtual; abstract;
  40.     // Translate a relative URI to a local absolute path
  41.     function TranslateURI(const URI: string): string; virtual; abstract;
  42.     // Write count bytes back to client
  43.     function WriteClient(var Buffer; Count: Integer): Integer; virtual; abstract;
  44.     // Write string contents back to client
  45.     function WriteString(const AString: string): Boolean; virtual; abstract;
  46.     // Utility to extract fields from a given string buffer
  47.     procedure ExtractFields(Separators, WhiteSpace: TCharSet;
  48.       Content: PChar; Strings: TStrings);
  49.     // Fills the given string list with the content fields as the result
  50.     // of a POST method
  51.     procedure ExtractContentFields(Strings: TStrings);
  52.     // Fills the given string list with values from the cookie header field
  53.     procedure ExtractCookieFields(Strings: TStrings);
  54.     // Fills the given TStrings with the values from the Query data
  55.     // (ie: data following the "?" in the URL)
  56.     procedure ExtractQueryFields(Strings: TStrings);
  57.     // Read an arbitrary HTTP/Server Field not lists here
  58.     function GetFieldByName(const Name: string): string; virtual; abstract;
  59.     // The request method as an enumeration
  60.     property MethodType: TMethodType read FMethodType;
  61.     // Field lists
  62.     property ContentFields: TStrings read GetContentFields;
  63.     property CookieFields: TStrings read GetCookieFields;
  64.     property QueryFields: TStrings read GetQueryFields;
  65.     // HTTP header Fields
  66.     property Method: string index 0 read GetStringVariable;
  67.     property ProtocolVersion: string index 1 read GetStringVariable;
  68.     property URL: string index 2 read GetStringVariable;
  69.     property Query: string index 3 read GetStringVariable;
  70.     property PathInfo: string index 4 read GetStringVariable;
  71.     property PathTranslated: string index 5 read GetStringVariable;
  72.     property Authorization: string index 28 read GetStringVariable;
  73.     property CacheControl: string index 6 read GetStringVariable;
  74.     property Cookie: string index 27 read GetStringVariable;
  75.     property Date: TDateTime index 7 read GetDateVariable;
  76.     property Accept: string index 8 read GetStringVariable;
  77.     property From: string index 9 read GetStringVariable;
  78.     property Host: string index 10 read GetStringVariable;
  79.     property IfModifiedSince: TDateTime index 11 read GetDateVariable;
  80.     property Referer: string index 12 read GetStringVariable;
  81.     property UserAgent: string index 13 read GetStringVariable;
  82.     property ContentEncoding: string index 14 read GetStringVariable;
  83.     property ContentType: string index 15 read GetStringVariable;
  84.     property ContentLength: Integer index 16 read GetIntegerVariable;
  85.     property ContentVersion: string index 17 read GetStringVariable;
  86.     property Content: string index 25 read GetStringVariable;
  87.     property Connection: string index 26 read GetStringVariable;
  88.     property DerivedFrom: string index 18 read GetStringVariable;
  89.     property Expires: TDateTime index 19 read GetDateVariable;
  90.     property Title: string index 20 read GetStringVariable;
  91.     property RemoteAddr: string index 21 read GetStringVariable;
  92.     property RemoteHost: string index 22 read GetStringVariable;
  93.     property ScriptName: string index 23 read GetStringVariable;
  94.     property ServerPort: Integer index 24 read GetIntegerVariable;
  95.   end;
  96.  
  97. { TWebResponse }
  98.  
  99.   TWebResponse = class(TObject)
  100.   private
  101.     FContentStream: TStream;
  102.     FCustomHeaders: TStrings;
  103.     procedure SetCustomHeaders(Value: TStrings);
  104.   protected
  105.     FHTTPRequest: TWebRequest;
  106.     procedure AddCustomHeaders(var Headers: string);
  107.     function GetStringVariable(Index: Integer): string; virtual; abstract;
  108.     procedure SetStringVariable(Index: Integer; const Value: string); virtual; abstract;
  109.     function GetDateVariable(Index: Integer): TDateTime; virtual; abstract;
  110.     procedure SetDateVariable(Index: Integer; const Value: TDateTime); virtual; abstract;
  111.     function GetIntegerVariable(Index: Integer): Integer; virtual; abstract;
  112.     procedure SetIntegerVariable(Index: Integer; Value: Integer); virtual; abstract;
  113.     function GetContent: string; virtual; abstract;
  114.     procedure SetContent(const Value: string); virtual; abstract;
  115.     procedure SetContentStream(Value: TStream); virtual;
  116.     function GetStatusCode: Integer; virtual; abstract;
  117.     procedure SetStatusCode(Value: Integer); virtual; abstract;
  118.     function GetLogMessage: string; virtual; abstract;
  119.     procedure SetLogMessage(const Value: string); virtual; abstract;
  120.     function Sent: Boolean; virtual;
  121.   public
  122.     constructor Create(HTTPRequest: TWebRequest);
  123.     destructor Destroy; override;
  124.     function GetCustomHeader(const Name: string): String;
  125.     procedure SendResponse; virtual; abstract;
  126.     procedure SendRedirect(const URI: string); virtual; abstract;
  127.     procedure SendStream(AStream: TStream); virtual; abstract;
  128.     procedure SetCookieField(Values: TStrings; const Domain, Path: string;
  129.       Expires: TDateTime; Secure: Boolean);
  130.     procedure SetCustomHeader(const Name, Value: string);
  131.     property HTTPRequest: TWebRequest read FHTTPRequest;
  132.     property Version: string index 0 read GetStringVariable write SetStringVariable;
  133.     property ReasonString: string index 1 read GetStringVariable write SetStringVariable;
  134.     property Server: string index 2 read GetStringVariable write SetStringVariable;
  135.     property WWWAuthenticate: string index 3 read GetStringVariable write SetStringVariable;
  136.     property Realm: string index 4 read GetStringVariable write SetStringVariable;
  137.     property Allow: string index 5 read GetStringVariable write SetStringVariable;
  138.     property Location: string index 6 read GetStringVariable write SetStringVariable;
  139.     property ContentEncoding: string index 7 read GetStringVariable write SetStringVariable;
  140.     property ContentType: string index 8 read GetStringVariable write SetStringVariable;
  141.     property ContentVersion: string index 9 read GetStringVariable write SetStringVariable;
  142.     property DerivedFrom: string index 10 read GetStringVariable write SetStringVariable;
  143.     property Title: string index 11 read GetStringVariable write SetStringVariable;
  144.     property SetCookie: string index 12 read GetStringVariable write SetStringVariable;
  145.  
  146.     property StatusCode: Integer read GetStatusCode write SetStatusCode;
  147.     property ContentLength: Integer index 0 read GetIntegerVariable write SetIntegerVariable;
  148.  
  149.     property Date: TDateTime index 0 read GetDateVariable write SetDateVariable;
  150.     property Expires: TDateTime index 1 read GetDateVariable write SetDateVariable;
  151.     property LastModified: TDateTime index 2 read GetDateVariable write SetDateVariable;
  152.  
  153.     property Content: string read GetContent write SetContent;
  154.     property ContentStream: TStream read FContentStream write SetContentStream;
  155.  
  156.     property LogMessage: string read GetLogMessage write SetLogMessage;
  157.  
  158.     property CustomHeaders: TStrings read FCustomHeaders write SetCustomHeaders;
  159.   end;
  160.  
  161. { TWebDispatcherEditor }
  162.  
  163.   TCustomWebDispatcher = class;
  164.   TCustomContentProducer = class;
  165.  
  166. { THTMLTagAttributes }
  167.  
  168.   THTMLAlign = (haDefault, haLeft, haRight, haCenter);
  169.   THTMLVAlign = (haVDefault, haTop, haMiddle, haBottom, haBaseline);
  170.   THTMLBgColor = type string;
  171.  
  172.   THTMLTagAttributes = class(TPersistent)
  173.   private
  174.     FProducer: TCustomContentProducer;
  175.     FCustom: string;
  176.     FOnChange: TNotifyEvent;
  177.     procedure SetCustom(const Value: string);
  178.   protected
  179.     procedure Changed;
  180.   public
  181.     constructor Create(Producer: TCustomContentProducer);
  182.     property Producer: TCustomContentProducer read FProducer;
  183.     property OnChange: TNotifyEvent read FOnChange write FOnChange;
  184.   published
  185.     property Custom: string read FCustom write SetCustom;
  186.   end;
  187.  
  188.   THTMLTableAttributes = class(THTMLTagAttributes)
  189.   private
  190.     FAlign: THTMLAlign;
  191.     FBorder: Integer;
  192.     FBgColor: THTMLBgColor;
  193.     FCellSpacing: Integer;
  194.     FCellPadding: Integer;
  195.     FWidth: Integer;
  196.     procedure SetAlign(Value: THTMLAlign);
  197.     procedure SetBorder(Value: Integer);
  198.     procedure SetBGColor(Value: THTMLBgColor);
  199.     procedure SetCellSpacing(Value: Integer);
  200.     procedure SetCellPadding(Value: Integer);
  201.     procedure SetWidth(Value: Integer);
  202.   protected
  203.     procedure AssignTo(Dest: TPersistent); override;
  204.   public
  205.     constructor Create(Producer: TCustomContentProducer);
  206.   published
  207.     property Align: THTMLAlign read FAlign write SetAlign default haDefault;
  208.     property BgColor: THTMLBgColor read FBgColor write SetBgColor;
  209.     property Border: Integer read FBorder write SetBorder default -1;
  210.     property CellSpacing: Integer read FCellSpacing write SetCellSpacing default -1;
  211.     property CellPadding: Integer read FCellPadding write SetCellPAdding default -1;
  212.     property Width: Integer read FWidth write SetWidth default 100;
  213.   end;
  214.  
  215.   THTMLTableElementAttributes = class(THTMLTagAttributes)
  216.   private
  217.     FAlign: THTMLAlign;
  218.     FBgColor: THTMLBgColor;
  219.     FVAlign: THTMLVAlign;
  220.     procedure SetAlign(Value: THTMLAlign);
  221.     procedure SetBGColor(Value: THTMLBgColor);
  222.     procedure SetVAlign(Value: THTMLVAlign);
  223.   protected
  224.     procedure AssignTo(Dest: TPersistent); override;
  225.   published
  226.     property Align: THTMLAlign read FAlign write SetAlign default haDefault;
  227.     property BgColor: THTMLBgColor read FBgColor write SetBgColor;
  228.     property VAlign: THTMLVAlign read FVAlign write SetVAlign default haVDefault;
  229.   end;
  230.  
  231.   THTMLTableHeaderAttributes = class(THTMLTableElementAttributes)
  232.   private
  233.     FCaption: string;
  234.     procedure Sestring(Value: string);
  235.   protected
  236.     procedure AssignTo(Dest: TPersistent); override;
  237.   published
  238.     property Caption: string read FCaption write Sestring;
  239.   end;  
  240.  
  241.   THTMLTableRowAttributes = class(THTMLTableElementAttributes);
  242.   THTMLTableCellAttributes = class(THTMLTableElementAttributes);
  243.  
  244. { TCustomContentProducer }
  245.  
  246.   TCustomContentProducer = class(TComponent)
  247.   private
  248.     FDispatcher: TCustomWebDispatcher;
  249.     procedure SetDispatcher(Value: TCustomWebDispatcher);
  250.   protected
  251.     procedure Notification(AComponent: TComponent; Operation: TOperation); override;
  252.   public
  253.     function Content: string; virtual;
  254.     function ContentFromStream(Stream: TStream): string; virtual;
  255.     function ContentFromString(const S: string): string; virtual;
  256.   published  
  257.     property Dispatcher: TCustomWebDispatcher read FDispatcher
  258.       write SetDispatcher stored False;
  259.   end;
  260.  
  261. { TCustomHTTPPageProducer }
  262.  
  263.   TCustomPageProducer = class(TCustomContentProducer)
  264.   private
  265.     FHTMLFile: TFileName;
  266.     FHTMLDoc: TStrings;
  267.     procedure SetHTMLFile(const Value: TFileName);
  268.     procedure SetHTMLDoc(Value: TStrings);
  269.   protected
  270.     function HandleTag(const TagString: string; TagParams: TStrings): string; virtual;
  271.     property HTMLDoc: TStrings read FHTMLDoc write SetHTMLDoc;
  272.     property HTMLFile: TFileName read FHTMLFile write SetHTMLFile;
  273.   public
  274.     constructor Create(AOwner: TComponent); override;
  275.     destructor Destroy; override;
  276.     function Content: string; override;
  277.     function ContentFromStream(Stream: TStream): string; override;
  278.     function ContentFromString(const S: string): string; override;
  279.   end;
  280.  
  281. { TPageProducer }
  282.  
  283.   TTag = (tgCustom, tgLink, tgImage, tgTable, tgImageMap, tgObject, tgEmbed);
  284.  
  285.   THTMLTagEvent = procedure (Sender: TObject; Tag: TTag; const TagString: string;
  286.     TagParams: TStrings; var ReplaceText: string) of object;
  287.  
  288.   TPageProducer = class(TCustomPageProducer)
  289.   private
  290.     FOnHTMLTag: THTMLTagEvent;
  291.   protected
  292.     function HandleTag(const TagString: string; TagParams: TStrings): string; override;
  293.     procedure DoTagEvent(Tag: TTag; const TagString: string; TagParams: TStrings;
  294.       var ReplaceText: string); dynamic;
  295.   published
  296.     property HTMLDoc;
  297.     property HTMLFile;
  298.     property OnHTMLTag: THTMLTagEvent read FOnHTMLTag write FOnHTMLTag;
  299.   end;
  300.  
  301. { TWebActionItem }
  302.  
  303.   THTTPMethodEvent = procedure (Sender: TObject; Request: TWebRequest;
  304.     Response: TWebResponse; var Handled: Boolean) of object;
  305.  
  306.   TWebActionItem = class(TCollectionItem)
  307.   private
  308.     FOnAction: THTTPMethodEvent;
  309.     FPathInfo: string;
  310.     FMethodType: TMethodType;
  311.     FDefault: Boolean;
  312.     FEnabled: Boolean;
  313.     FMask: TMask;
  314.     FName: string;
  315.     function DispatchAction(Request: TWebRequest; Response: TWebResponse;
  316.       DoDefault: Boolean): Boolean;
  317.     function GetDisplayName: string; override;
  318.     procedure SetDefault(Value: Boolean);
  319.     procedure SetEnabled(Value: Boolean);
  320.     procedure SetMethodType(Value: TMethodType);
  321.     procedure SetDisplayName(const Value: string); override;
  322.     procedure SetOnAction(Value: THTTPMethodEvent);
  323.     procedure SetPathInfo(const Value: string);
  324.   public
  325.     constructor Create(Collection: TCollection); override;
  326.     destructor Destroy; override;
  327.     procedure AssignTo(Dest: TPersistent); override;
  328.   published
  329.     property Default: Boolean read FDefault write SetDefault default False;
  330.     property Enabled: Boolean read FEnabled write SetEnabled default True;
  331.     property MethodType: TMethodType read FMethodType write SetMethodType default mtAny;
  332.     property Name: string read GetDisplayName write SetDisplayName;
  333.     property PathInfo: string read FPathInfo write SetPathInfo;
  334.     property OnAction: THTTPMethodEvent read FOnAction write SetOnAction;
  335.   end;
  336.  
  337. { TWebActionItems }
  338.  
  339.   TWebActionItems = class(TCollection)
  340.   private
  341.     FWebDispatcher: TCustomWebDispatcher;
  342.     function GetActionItem(Index: Integer): TWebActionItem;
  343.     procedure SetActionItem(Index: Integer; Value: TWebActionItem);
  344.   protected
  345.     function GetAttrCount: Integer; override;
  346.     function GetAttr(Index: Integer): string; override;
  347.     function GetItemAttr(Index, ItemIndex: Integer): string; override;
  348.     function GetOwner: TPersistent; override;
  349.     procedure SetItemName(Item: TCollectionItem); override;
  350.     procedure Update(Item: TCollectionItem); override;
  351.   public
  352.     constructor Create(WebDispatcher: TCustomWebDispatcher;
  353.       ItemClass: TCollectionItemClass);
  354.     function  Add: TWebActionItem;
  355.     property WebDispatcher: TCustomWebDispatcher read FWebDispatcher;
  356.     property Items[Index: Integer]: TWebActionItem read GetActionItem
  357.       write SetActionItem; default;
  358.   end;
  359.  
  360. { TCustomWebDispatcher }
  361.  
  362.   TCustomWebDispatcher = class(TDataModule)
  363.   private
  364.     FRequest: TWebRequest;
  365.     FResponse: TWebResponse;
  366.     FActions: TWebActionItems;
  367.     FBeforeDispatch: THTTPMethodEvent;
  368.     FAfterDispatch: THTTPMethodEvent;
  369.     function GetAction(Index: Integer): TWebActionItem;
  370.     procedure SetActions(Value: TWebActionItems);
  371.   protected
  372.     function DoAfterDispatch(Request: TWebRequest; Response: TWebResponse): Boolean;
  373.     function DoBeforeDispatch(Request: TWebRequest; Response: TWebResponse): Boolean;
  374.     function DispatchAction(Request: TWebRequest;
  375.       Response: TWebResponse): Boolean;
  376.     procedure Notification(AComponent: TComponent; Operation: TOperation); override;
  377.     property BeforeDispatch: THTTPMethodEvent read FBeforeDispatch write FBeforeDispatch;
  378.     property AfterDispatch: THTTPMethodEvent read FAfterDispatch write FAfterDispatch;
  379.   public
  380.     constructor Create(AOwner: TComponent); override;
  381.     destructor Destroy; override;
  382.     function ActionByName(const AName: string): TWebActionItem;
  383.     property Actions: TWebActionItems read FActions write SetActions;
  384.     property Action[Index: Integer]: TWebActionItem read GetAction;
  385.     property Request: TWebRequest read FRequest;
  386.     property Response: TWebResponse read FResponse;
  387.   end;
  388.  
  389. { TWebDispatcher }
  390.  
  391.   TWebDispatcher = class(TCustomWebDispatcher)
  392.   published
  393.     property Actions;
  394.     property BeforeDispatch;
  395.     property AfterDispatch;
  396.   end;
  397.  
  398. { TWebModule }
  399.  
  400.   TWebModule = class(TCustomWebDispatcher)
  401.   public
  402.     constructor Create(AOwner: TComponent); override;
  403.   published
  404.     property Actions;
  405.     property BeforeDispatch;
  406.     property AfterDispatch;
  407.   end;
  408.  
  409.   TWebApplication = class(TComponent)
  410.   private
  411.     FWebModuleClass: TComponentClass;
  412.     FCriticalSection: TCriticalSection;
  413.     FUniqueNumbers: TBits;
  414.     FActiveWebModules: TList;
  415.     FInactiveWebModules: TList;
  416.     FTitle: string;
  417.     FMaxConnections: Integer;
  418.     FCacheConnections: Boolean;
  419.     function GetActiveCount: Integer;
  420.     function GetInactiveCount: Integer;
  421.     procedure SetCacheConnections(Value: Boolean);
  422.     procedure OnExceptionHandler(Sender: TObject; E: Exception);
  423.   protected
  424.     function ActivateWebModule: TDataModule;
  425.     procedure DeactivateWebModule(DataModule: TDataModule);
  426.     procedure DoHandleException(E: Exception); dynamic;
  427.     function HandleRequest(Request: TWebRequest; Response: TWebResponse): Boolean;
  428.   public
  429.     constructor Create(AOwner: TComponent); override;
  430.     destructor Destroy; override;
  431.     // The following is uses the current behaviour of the IDE module manager
  432.     procedure CreateForm(InstanceClass: TComponentClass; var Reference); virtual;
  433.     procedure Initialize; virtual;
  434.     procedure Run; virtual;
  435.     property ActiveCount: Integer read GetActiveCount;
  436.     property CacheConnections: Boolean read FCacheConnections write SetCacheConnections;
  437.     property InactiveCount: Integer read GetInactiveCount;
  438.     property MaxConnections: Integer read FMaxConnections write FMaxConnections;
  439.     property Title: string read FTitle write FTitle;
  440.   end;
  441.  
  442. function DosPathToUnixPath(const Path: string): string;
  443. function HTTPDecode(const AStr: String): string;
  444. function HTTPEncode(const AStr: String): string;
  445. function ParseDate(const DateStr: string): TDateTime;
  446. procedure ExtractHTTPFields(Separators, WhiteSpace: TCharSet; Content: PChar;
  447.   Strings: TStrings);
  448. function StatusString(StatusCode: Integer): string;
  449. function UnixPathToDosPath(const Path: string): string;
  450.  
  451. var
  452.   Application: TWebApplication = nil;
  453.  
  454. implementation
  455.  
  456. uses Windows, CopyPrsr, WebConst;
  457.  
  458. { TWebRequest }
  459.  
  460. constructor TWebRequest.Create;
  461. begin
  462.   inherited Create;
  463.   if CompareText(Method, 'GET') = 0 then
  464.     FMethodType := mtGet
  465.   else if CompareText(Method, 'POST') = 0 then
  466.     FMethodType := mtPost
  467.   else if CompareText(Method, 'HEAD') = 0 then
  468.     FMethodType := mtHead;
  469. end;
  470.  
  471. destructor TWebRequest.Destroy;
  472. begin
  473.   FContentFields.Free;
  474.   FCookieFields.Free;
  475.   FQueryFields.Free;
  476.   inherited Destroy;
  477. end;
  478.  
  479. procedure TWebRequest.ExtractFields(Separators, WhiteSpace: TCharSet;
  480.   Content: PChar; Strings: TStrings);
  481. begin
  482.   ExtractHTTPFields(Separators, WhiteSpace, Content, Strings);
  483. end;
  484.  
  485. procedure TWebRequest.ExtractContentFields(Strings: TStrings);
  486. var
  487.   ContentStr: string;
  488. begin
  489.   if ContentLength > 0 then
  490.   begin
  491.     ContentStr := Content;
  492.     if Length(ContentStr) < ContentLength then
  493.       ContentStr := ContentStr + ReadString(ContentLength - Length(ContentStr));
  494.     ExtractFields(['&'], [], PChar(ContentStr), Strings);
  495.   end;
  496. end;
  497.  
  498. procedure TWebRequest.ExtractCookieFields(Strings: TStrings);
  499. var
  500.   CookieStr: string;
  501. begin
  502.   CookieStr := Cookie;
  503.   ExtractFields([';'], [' '], PChar(CookieStr), Strings);
  504. end;
  505.  
  506. procedure TWebRequest.ExtractQueryFields(Strings: TStrings);
  507. var
  508.   ContentStr: string;
  509. begin
  510.   ContentStr := Query;
  511.   ExtractFields(['&'], [], PChar(ContentStr), Strings);
  512. end;
  513.  
  514. function TWebRequest.GetContentFields: TStrings;
  515. begin
  516.   if FContentFields = nil then
  517.   begin
  518.     FContentFields := TStringList.Create;
  519.     ExtractContentFields(FContentFields);
  520.   end;
  521.   Result := FContentFields;
  522. end;
  523.  
  524. function TWebRequest.GetCookieFields: TStrings;
  525. begin
  526.   if FCookieFields = nil then
  527.   begin
  528.     FCookieFields := TStringList.Create;
  529.     ExtractCookieFields(FCookieFields);
  530.   end;
  531.   Result := FCookieFields;
  532. end;
  533.  
  534. function TWebRequest.GetQueryFields: TStrings;
  535. begin
  536.   if FQueryFields = nil then
  537.   begin
  538.     FQueryFields := TStringList.Create;
  539.     ExtractQueryFields(FQueryFields);
  540.   end;
  541.   Result := FQueryFields;
  542. end;
  543.  
  544. { TWebResponse }
  545.  
  546. constructor TWebResponse.Create(HTTPRequest: TWebRequest);
  547. begin
  548.   inherited Create;
  549.   FHTTPRequest := HTTPRequest;
  550.   FCustomHeaders := TStringList.Create;
  551. end;
  552.  
  553. destructor TWebResponse.Destroy;
  554. begin
  555.   FContentStream.Free;
  556.   FCustomHeaders.Free;
  557.   inherited Destroy;
  558. end;
  559.  
  560. procedure TWebResponse.AddCustomHeaders(var Headers: string);
  561. var
  562.   I: Integer;
  563.   Name, Value: string;
  564. begin
  565.   for I := 0 to FCustomHeaders.Count - 1 do
  566.   begin
  567.     Name := FCustomHeaders.Names[I];
  568.     Value := FCustomHeaders.values[Name];
  569.     Headers := Headers + Name + ': ' + Value + #13#10;
  570.   end;
  571. end;
  572.  
  573. function TWebResponse.GetCustomHeader(const Name: string): string;
  574. begin
  575.   Result := FCustomHeaders.Values[Name];
  576. end;
  577.  
  578. function TWebResponse.Sent: Boolean;
  579. begin
  580.   Result := False;
  581. end;
  582.  
  583. procedure TWebResponse.SetContentStream(Value: TStream);
  584. begin
  585.   if Value <> FContentStream then
  586.   begin
  587.     FContentStream.Free;
  588.     FContentStream := Value;
  589.     if FContentStream <> nil then
  590.       ContentLength := FContentStream.Size;
  591.   end;
  592. end;
  593.  
  594. procedure TWebResponse.SetCookieField(Values: TStrings; const Domain,
  595.   Path: string; Expires: TDateTime; Secure: Boolean);
  596. var
  597.   CookieStr: string;
  598.   I: Integer;
  599. begin
  600.   for I := 0 to Values.Count - 1 do
  601.     CookieStr := CookieStr + HTTPEncode(Values[I]) + '; ';
  602.   if Domain <> '' then
  603.     CookieStr := CookieStr + Format('domain=%s', [HTTPEncode(Domain)]);
  604.   if Path <> '' then
  605.     CookieStr := CookieStr + Format('path=%s', [HTTPEncode(Path)]);
  606.   if Expires > -1 then
  607.     CookieStr := CookieStr + FormatDateTime('"expires="' + DateFormat + ' "GMT; "', Expires);
  608.   if Secure then CookieStr := CookieStr + 'secure';
  609.   SetCookie := CookieStr;
  610. end;
  611.  
  612. procedure TWebResponse.SetCustomHeader(const Name, Value: string);
  613. begin
  614.   FCustomHeaders.Values[Name] := Value;
  615. end;
  616.  
  617. procedure TWebResponse.SetCustomHeaders(Value: TStrings);
  618. begin
  619.   FCustomHeaders.Assign(Value);
  620. end;
  621.  
  622. { THTMLTagAttributes }
  623.  
  624. constructor THTMLTagAttributes.Create(Producer: TCustomContentProducer);
  625. begin
  626.   inherited Create;
  627.   FProducer := Producer;
  628. end;
  629.  
  630. procedure THTMLTagAttributes.Changed;
  631. begin
  632.   if Assigned(FOnChange) then FOnChange(Self);
  633. end;
  634.  
  635. procedure THTMLTagAttributes.SetCustom(const Value: string);
  636. begin
  637.   if Value <> FCustom then
  638.   begin
  639.     FCustom := Value;
  640.     Changed;
  641.   end;
  642. end;
  643.  
  644. { THTMLTableAttributes }
  645.  
  646. constructor THTMLTableAttributes.Create(Producer: TCustomContentProducer);
  647. begin
  648.   inherited Create(Producer);
  649.   FWidth := 100;
  650.   FBorder := -1;
  651.   FCellPadding := -1;
  652.   FCellSpacing := -1;
  653. end;
  654.  
  655. procedure THTMLTableAttributes.AssignTo(Dest: TPersistent);
  656. begin
  657.   if Dest is THTMLTableAttributes then
  658.     with THTMLTableAttributes(Dest) do
  659.     begin
  660.       FWidth := Self.FWidth;
  661.       FAlign := Self.FAlign;
  662.       FBorder := Self.FBorder;
  663.       FBgColor := Self.FBgColor;
  664.       FCellSpacing := Self.FCellSpacing;
  665.       FCellPadding := Self.FCellPadding;
  666.       Changed;
  667.     end else inherited AssignTo(Dest);
  668. end;
  669.  
  670. procedure THTMLTableAttributes.SetAlign(Value: THTMLAlign);
  671. begin
  672.   if Value <> FAlign then
  673.   begin
  674.     FAlign := Value;
  675.     Changed;
  676.   end;
  677. end;
  678.  
  679. procedure THTMLTableAttributes.SetBorder(Value: Integer);
  680. begin
  681.   if Value <> FBorder then
  682.   begin
  683.     FBorder := Value;
  684.     Changed;
  685.   end;
  686. end;
  687.  
  688. procedure THTMLTableAttributes.SetBGColor(Value: THTMLBgColor);
  689. begin
  690.   if Value <> FBgColor then
  691.   begin
  692.     FBgColor := Value;
  693.     Changed;
  694.   end;
  695. end;
  696.  
  697. procedure THTMLTableAttributes.SetCellSpacing(Value: Integer);
  698. begin
  699.   if Value <> FCellSpacing then
  700.   begin
  701.     FCellSpacing := Value;
  702.     Changed;
  703.   end;
  704. end;
  705.  
  706. procedure THTMLTableAttributes.SetCellPadding(Value: Integer);
  707. begin
  708.   if Value <> FCellPadding then
  709.   begin
  710.     FCellPadding := Value;
  711.     Changed;
  712.   end;
  713. end;
  714.  
  715. procedure THTMLTableAttributes.SetWidth(Value: Integer);
  716. begin
  717.   if Value <> FWidth then
  718.   begin
  719.     FWidth := Value;
  720.     Changed;
  721.   end;
  722. end;
  723.  
  724. { THTMLTableElementAttributes }
  725.  
  726. procedure THTMLTableElementAttributes.AssignTo(Dest: TPersistent);
  727. begin
  728.   if Dest is THTMLTableElementAttributes then
  729.     with THTMLTableElementAttributes(Dest) do
  730.     begin
  731.       FAlign := Self.FAlign;
  732.       FVAlign := Self.FVAlign;
  733.       FBgColor := Self.FBgColor;
  734.       Changed;
  735.     end else inherited AssignTo(Dest);
  736. end;
  737.  
  738. procedure THTMLTableElementAttributes.SetAlign(Value: THTMLAlign);
  739. begin
  740.   if Value <> FAlign then
  741.   begin
  742.     FAlign := Value;
  743.     Changed;
  744.   end;
  745. end;
  746.  
  747. procedure THTMLTableElementAttributes.SetBGColor(Value: THTMLBgColor);
  748. begin
  749.   if Value <> FBgColor then
  750.   begin
  751.     FBgColor := Value;
  752.     Changed;
  753.   end;
  754. end;
  755.  
  756. procedure THTMLTableElementAttributes.SetVAlign(Value: THTMLVAlign);
  757. begin
  758.   if Value <> FVAlign then
  759.   begin
  760.     FVAlign := Value;
  761.     Changed;
  762.   end;
  763. end;
  764.  
  765. { THTMLTableHeaderAttributes }
  766.  
  767. procedure THTMLTableHeaderAttributes.AssignTo(Dest: TPersistent);
  768. begin
  769.   if Dest is THTMLTableHeaderAttributes then
  770.     with THTMLTableHeaderAttributes(Dest) do
  771.     begin
  772.       FAlign := Self.FAlign;
  773.       FVAlign := Self.FVAlign;
  774.       FBgColor := Self.FBgColor;
  775.       FCaption := Self.FCaption;
  776.       Changed;
  777.     end else inherited AssignTo(Dest);
  778. end;
  779.  
  780. procedure THTMLTableHeaderAttributes.Sestring(Value: string);
  781. begin
  782.   if AnsiCompareStr(Value, FCaption) <> 0 then
  783.   begin
  784.     FCaption := Value;
  785.     Changed;
  786.   end;
  787. end;
  788.  
  789. { TCustomHTMLProducer }
  790.  
  791. procedure TCustomContentProducer.Notification(AComponent: TComponent;
  792.   Operation: TOperation);
  793. begin
  794.   inherited Notification(AComponent, Operation);
  795.   if (Operation = opRemove) and (AComponent = FDispatcher) then
  796.     FDispatcher := nil;
  797. end;
  798.  
  799. procedure TCustomContentProducer.SetDispatcher(Value: TCustomWebDispatcher);
  800. begin
  801.   if FDispatcher <> Value then
  802.   begin
  803.     if Value <> nil then Value.FreeNotification(Self);
  804.     FDispatcher := Value;
  805.   end;
  806. end;
  807.  
  808. function TCustomContentProducer.Content: string;
  809. begin
  810.   Result := '';
  811. end;
  812.  
  813. function TCustomContentProducer.ContentFromStream(Stream: TStream): string;
  814. begin
  815.   Result := Content;
  816. end;
  817.  
  818. function TCustomContentProducer.ContentFromString(const S: string): string;
  819. begin
  820.   Result := Content;
  821. end;
  822.  
  823. { TCustomPageProducer }
  824.  
  825. constructor TCustomPageProducer.Create(AOwner: TComponent);
  826. begin
  827.   inherited Create(AOwner);
  828.   FHTMLDoc := TStringList.Create;
  829. end;
  830.  
  831. destructor TCustomPageProducer.Destroy;
  832. begin
  833.   FHTMLDoc.Free;
  834.   inherited Destroy;
  835. end;
  836.  
  837. function TCustomPageProducer.Content: string;
  838. var
  839.   InStream: TStream;
  840. begin
  841.   Result := '';
  842.   if FHTMLFile <> '' then
  843.     InStream := TFileStream.Create(FHTMLFile, fmOpenRead + fmShareDenyWrite)
  844.   else InStream := TStringStream.Create(FHTMLDoc.Text);
  845.   if InStream <> nil then
  846.   try
  847.     Result := ContentFromStream(InStream);
  848.   finally
  849.     InStream.Free;
  850.   end;
  851. end;
  852.  
  853. function TCustomPageProducer.ContentFromStream(Stream: TStream): string;
  854. var
  855.   Parser: TCopyParser;
  856.   OutStream: TStringStream;
  857.   ParamStr, ReplaceStr, TokenStr: string;
  858.   ParamList: TStringList;
  859. begin
  860.   OutStream := TStringStream.Create('');
  861.   try
  862.     Parser := TCopyParser.Create(Stream, OutStream);
  863.     with Parser do
  864.     try
  865.       while True do
  866.       begin
  867.         while not (Token in [toEof, '<']) do
  868.         begin
  869.           CopyTokenToOutput;
  870.           SkipToken(True);
  871.         end;
  872.         if Token = toEOF then Break;
  873.         if Token = '<' then
  874.         begin
  875.           if SkipToken(False) = '#' then
  876.           begin
  877.             SkipToken(False);
  878.             TokenStr := TokenString;
  879.             ParamStr := TrimLeft(TrimRight(SkipToToken('>')));
  880.             ParamList := TStringList.Create;
  881.             try
  882.               ExtractHTTPFields([' '], [' '], PChar(ParamStr), ParamList);
  883.               ReplaceStr := HandleTag(TokenStr, ParamList);
  884.               OutStream.WriteString(ReplaceStr);
  885.             finally
  886.               ParamList.Free;
  887.             end;
  888.             SkipToken(True);
  889.           end else
  890.           begin
  891.             OutStream.WriteString('<');
  892.             CopyTokenToOutput;
  893.             SkipToken(True);
  894.           end;
  895.         end;
  896.       end;
  897.     finally
  898.       Parser.Free;
  899.     end;
  900.     Result := OutStream.DataString;
  901.   finally
  902.     OutStream.Free;
  903.   end;
  904. end;
  905.  
  906. function TCustomPageProducer.ContentFromString(const S: string): string;
  907. var
  908.   InStream: TStream;
  909. begin
  910.   InStream := TStringStream.Create(S);
  911.   try
  912.     Result := ContentFromStream(InStream);
  913.   finally
  914.     InStream.Free;
  915.   end;
  916. end;
  917.  
  918. function TCustomPageProducer.HandleTag(const TagString: string; TagParams: TStrings): string;
  919. begin
  920.   Result := Format('<#%s>', [TagString]);
  921. end;
  922.  
  923. procedure TCustomPageProducer.SetHTMLFile(const Value: string);
  924. begin
  925.   if CompareText(FHTMLFile, Value) <> 0 then
  926.   begin
  927.     FHTMLDoc.Clear;
  928.     FHTMLFile := Value;
  929.   end;
  930. end;
  931.  
  932. procedure TCustomPageProducer.SetHTMLDoc(Value: TStrings);
  933. begin
  934.   FHTMLDoc.Assign(Value);
  935.   FHTMLFile := '';
  936. end;
  937.  
  938. { TPageProducer }
  939.  
  940. var
  941.   TagSymbols: array[TTag] of string =
  942.     ('', 'LINK', 'IMAGE', 'TABLE', 'IMAGEMAP', 'OBJECT', 'EMBED');
  943.  
  944. function TPageProducer.HandleTag(const TagString: string; TagParams: TStrings): string;
  945. var
  946.   Tag: TTag;
  947. begin
  948.   Tag := High(TTag);
  949.   while Tag >= Low(TTag) do
  950.   begin
  951.     if (Tag = tgCustom) or (CompareText(TagSymbols[Tag], TagString) = 0) then Break;
  952.     Dec(Tag);
  953.   end;
  954.   Result := '';
  955.   DoTagEvent(Tag, TagString, TagParams, Result);
  956. end;
  957.  
  958. procedure TPageProducer.DoTagEvent(Tag: TTag; const TagString: string;
  959.   TagParams: TStrings; var ReplaceText: string);
  960. begin
  961.   if Assigned(FOnHTMLTag) then
  962.     FOnHTMLTag(Self, Tag, TagString, TagParams, ReplaceText);
  963. end;
  964.  
  965. { TWebActionItem }
  966.  
  967. constructor TWebActionItem.Create(Collection: TCollection);
  968. begin
  969.   inherited Create(Collection);
  970.   FEnabled := True;
  971.   FMask := TMask.Create('');
  972. end;
  973.  
  974. destructor TWebActionItem.Destroy;
  975. begin
  976.   FMask.Free;
  977.   inherited Destroy;
  978. end;
  979.  
  980. procedure TWebActionItem.AssignTo(Dest: TPersistent);
  981. begin
  982.   if Dest is TWebActionItem then
  983.   begin
  984.     if Assigned(Collection) then Collection.BeginUpdate;
  985.     try
  986.       with TWebActionItem(Dest) do
  987.       begin
  988.         Default := Self.Default;
  989.         PathInfo := Self.PathInfo;
  990.         Enabled := Self.Enabled;
  991.         MethodType := Self.MethodType;
  992.       end;
  993.     finally
  994.       if Assigned(Collection) then Collection.EndUpdate;
  995.     end;
  996.   end else inherited AssignTo(Dest);
  997. end;
  998.  
  999. function TWebActionItem.DispatchAction(Request: TWebRequest; Response: TWebResponse;
  1000.   DoDefault: Boolean): Boolean;
  1001. begin
  1002.   Result := False;
  1003.   if (FDefault and DoDefault) or (FEnabled and ((FMethodType = mtAny) or
  1004.     (FMethodType = Request.MethodType)) and
  1005.     FMask.Matches(Request.PathInfo)) then
  1006.     if Assigned(FOnAction) then
  1007.     begin
  1008.       Result := True;
  1009.       FOnAction(Self, Request, Response, Result);
  1010.     end;
  1011. end;
  1012.  
  1013. function TWebActionItem.GetDisplayName: string;
  1014. begin
  1015.   Result := FName;
  1016. end;
  1017.  
  1018. procedure TWebActionItem.SetDefault(Value: Boolean);
  1019. var
  1020.   I: Integer;
  1021.   Action: TWebActionItem;
  1022. begin
  1023.   if Value <> FDefault then
  1024.   begin
  1025.     if Value and (Collection <> nil) then
  1026.       for I := 0 to Collection.Count - 1 do
  1027.       begin
  1028.         Action := TWebActionItems(Collection).Items[I];
  1029.         if (Action <> Self) and (Action is TWebActionItem) then
  1030.           Action.Default := False;
  1031.       end;
  1032.     FDefault := Value;
  1033.     Changed(False);
  1034.   end;
  1035. end;
  1036.  
  1037. procedure TWebActionItem.SetEnabled(Value: Boolean);
  1038. begin
  1039.   if Value <> FEnabled then
  1040.   begin
  1041.     FEnabled := Value;
  1042.     Changed(False);
  1043.   end;
  1044. end;
  1045.  
  1046. procedure TWebActionItem.SetMethodType(Value: TMethodType);
  1047. begin
  1048.   if Value <> FMethodType then
  1049.   begin
  1050.     FMethodType := Value;
  1051.     Changed(False);
  1052.   end;
  1053. end;
  1054.  
  1055. procedure TWebActionItem.SetDisplayName(const Value: string);
  1056. var
  1057.   I: Integer;
  1058.   Action: TWebActionItem;
  1059. begin
  1060.   if AnsiCompareText(Value, FName) <> 0 then
  1061.   begin
  1062.     if Collection <> nil then
  1063.       for I := 0 to Collection.Count - 1 do
  1064.       begin
  1065.         Action := TWebActionItems(Collection).Items[I];
  1066.         if (Action <> Self) and (Action is TWebActionItem) and
  1067.           (AnsiCompareText(Value, Action.Name) = 0) then
  1068.           raise Exception.Create(sDuplicateActionName);
  1069.       end;
  1070.     FName := Value;
  1071.     Changed(False);
  1072.   end;
  1073. end;
  1074.  
  1075. procedure TWebActionItem.SetOnAction(Value: THTTPMethodEvent);
  1076. begin
  1077.   FOnAction := Value;
  1078.   Changed(False);
  1079. end;
  1080.  
  1081. procedure TWebActionItem.SetPathInfo(const Value: string);
  1082. var
  1083.   Mask: TMask;
  1084.   NewValue: string;
  1085. begin
  1086.   if Value <> '' then NewValue := DosPathToUnixPath(Value);
  1087.   if (NewValue <> '') and (NewValue[1] <> '/') then Insert('/', NewValue, 1);
  1088.   if AnsiCompareText(FPathInfo, NewValue) <> 0 then
  1089.   begin
  1090.     Mask := TMask.Create(NewValue);
  1091.     try
  1092.       FPathInfo := NewValue;
  1093.       FMask.Free;
  1094.       FMask := nil;
  1095.     except
  1096.       Mask.Free;
  1097.       raise;
  1098.     end;
  1099.     FMask := Mask;
  1100.     Changed(False);
  1101.   end;
  1102. end;
  1103.  
  1104. { TWebActionItems }
  1105.  
  1106. constructor TWebActionItems.Create(WebDispatcher: TCustomWebDispatcher;
  1107.   ItemClass: TCollectionItemClass);
  1108. begin
  1109.   inherited Create(ItemClass);
  1110.   FWebDispatcher := WebDispatcher;
  1111. end;
  1112.  
  1113. function TWebActionItems.Add: TWebActionItem;
  1114. begin
  1115.   Result := TWebActionItem(inherited Add);
  1116. end;
  1117.  
  1118. function TWebActionItems.GetActionItem(Index: Integer): TWebActionItem;
  1119. begin
  1120.   Result := TWebActionItem(inherited Items[Index]);
  1121. end;
  1122.  
  1123. function TWebActionItems.GetAttrCount: Integer;
  1124. begin
  1125.   Result := 4;
  1126. end;
  1127.  
  1128. function TWebActionItems.GetAttr(Index: Integer): string;
  1129. begin
  1130.   case Index of
  1131.     0: Result := sHTTPItemName;
  1132.     1: Result := sHTTPItemURI;
  1133.     2: Result := sHTTPItemEnabled;
  1134.     3: Result := sHTTPItemDefault;
  1135.   else
  1136.     Result := '';
  1137.   end;
  1138. end;
  1139.  
  1140. function TWebActionItems.GetItemAttr(Index, ItemIndex: Integer): string;
  1141. begin
  1142.   case Index of
  1143.     0: Result := Items[ItemIndex].Name;
  1144.     1: Result := Items[ItemIndex].PathInfo;
  1145.     2: if Items[ItemIndex].Enabled then
  1146.          Result := 'True' else Result := 'False'; // do not localize
  1147.     3: if Items[ItemIndex].Default then
  1148.          Result := '*' else Result := '';  //do not localize
  1149.   else
  1150.     Result := '';
  1151.   end;
  1152. end;
  1153.  
  1154. function TWebActionItems.GetOwner: TPersistent;
  1155. begin
  1156.   Result := FWebDispatcher;
  1157. end;
  1158.  
  1159. procedure TWebActionItems.SetActionItem(Index: Integer; Value: TWebActionItem);
  1160. begin
  1161.   Items[Index].Assign(Value);
  1162. end;
  1163.  
  1164. procedure TWebActionItems.SetItemName(Item: TCollectionItem);
  1165. var
  1166.   I, J: Integer;
  1167.   ItemName: string;
  1168.   CurItem: TWebActionItem;
  1169. begin
  1170.   J := 1;
  1171.   while True do
  1172.   begin
  1173.     ItemName := Format('WebActionItem%d', [J]);
  1174.     I := 0;
  1175.     while I < Count do
  1176.     begin
  1177.       CurItem := Items[I] as TWebActionItem;
  1178.       if (CurItem <> Item) and (CompareText(CurItem.Name, ItemName) = 0) then
  1179.       begin
  1180.         Inc(J);
  1181.         Break;
  1182.       end;
  1183.       Inc(I);
  1184.     end;
  1185.     if I >= Count then
  1186.     begin
  1187.       (Item as TWebActionItem).Name := ItemName;
  1188.       Break;
  1189.     end;
  1190.   end;
  1191. end;
  1192.  
  1193. procedure TWebActionItems.Update(Item: TCollectionItem);
  1194. begin
  1195. {!!!  if (FWebDispatcher <> nil) and
  1196.     not (csLoading in FWebDispatcher.ComponentState) then }
  1197. end;
  1198.  
  1199. { TCustomWebDispatcher }
  1200.  
  1201. constructor TCustomWebDispatcher.Create(AOwner: TComponent);
  1202. var
  1203.   I: Integer;
  1204.   Component: TComponent;
  1205. begin
  1206.   if AOwner <> nil then
  1207.     if AOwner is TCustomWebDispatcher then
  1208.       raise Exception.Create(sOnlyOneDispatcher)
  1209.     else for I := 0 to AOwner.ComponentCount - 1 do
  1210.       if AOwner.Components[I] is TCustomWebDispatcher then
  1211.         raise Exception.Create(sOnlyOneDispatcher);
  1212.   inherited CreateNew(AOwner);
  1213.   FActions := TWebActionItems.Create(Self, TWebActionItem);
  1214.   if Owner <> nil then
  1215.     for I := 0 to Owner.ComponentCount - 1 do
  1216.     begin
  1217.       Component := Owner.Components[I];
  1218.       if Component is TCustomContentProducer then
  1219.         TCustomContentProducer(Component).Dispatcher := Self;
  1220.     end;
  1221. end;
  1222.  
  1223. destructor TCustomWebDispatcher.Destroy;
  1224. begin
  1225.   inherited Destroy;
  1226.   FActions.Free;
  1227. end;
  1228.  
  1229. function TCustomWebDispatcher.ActionByName(const AName: string): TWebActionItem;
  1230. var
  1231.   I: Integer;
  1232. begin
  1233.   for I := 0 to FActions.Count - 1 do
  1234.   begin
  1235.     Result := FActions[I];
  1236.     if AnsiCompareText(AName, Result.Name) = 0 then Exit;
  1237.   end;
  1238.   Result := nil;
  1239. end;
  1240.  
  1241. function TCustomWebDispatcher.DoAfterDispatch(Request: TWebRequest; Response: TWebResponse): Boolean;
  1242. begin
  1243.   Result := True;
  1244.   if Assigned(FAfterDispatch) then
  1245.     FAfterDispatch(Self, Request, Response, Result);
  1246. end;
  1247.  
  1248. function TCustomWebDispatcher.DoBeforeDispatch(Request: TWebRequest; Response: TWebResponse): Boolean;
  1249. begin
  1250.   Result := False;
  1251.   if Assigned(FBeforeDispatch) then
  1252.     FBeforeDispatch(Self, Request, Response, Result);
  1253. end;
  1254.  
  1255. function TCustomWebDispatcher.DispatchAction(Request: TWebRequest;
  1256.   Response: TWebResponse): Boolean;
  1257. var
  1258.   I: Integer;
  1259.   Action, Default: TWebActionItem;
  1260. begin
  1261.   FRequest := Request;
  1262.   FResponse := Response;
  1263.   I := 0;
  1264.   Default := nil;
  1265.   Result := DoBeforeDispatch(Request, Response) and Response.Sent;
  1266.   while not Result and (I < FActions.Count) do
  1267.   begin
  1268.     Action := FActions[I];
  1269.     Result := Action.DispatchAction(Request, Response, False);
  1270.     if Action.Default then Default := Action;
  1271.     Inc(I);
  1272.   end;
  1273.   if not Result and Assigned(Default) then
  1274.     Result := Default.DispatchAction(Request, Response, True);
  1275.   if Result and not Response.Sent then
  1276.     Result := DoAfterDispatch(Request, Response);
  1277. end;
  1278.  
  1279. function TCustomWebDispatcher.GetAction(Index: Integer): TWebActionItem;
  1280. begin
  1281.   Result := FActions[Index];
  1282. end;
  1283.  
  1284. procedure TCustomWebDispatcher.Notification(AComponent: TComponent;
  1285.   Operation: TOperation);
  1286. begin
  1287.   inherited Notification(AComponent, Operation);
  1288.   if (Operation = opInsert) and (AComponent is TCustomContentProducer) then
  1289.     TCustomContentProducer(AComponent).Dispatcher := Self;
  1290. end;
  1291.  
  1292. procedure TCustomWebDispatcher.SetActions(Value: TWebActionItems);
  1293. begin
  1294.   FActions.Assign(Value);
  1295. end;
  1296.  
  1297. { TWebModule }
  1298.  
  1299. constructor TWebModule.Create(AOwner: TComponent);
  1300. begin
  1301.   inherited Create(AOwner);
  1302.   if (ClassType <> TCustomWebDispatcher) and not (csDesigning in ComponentState) then
  1303.   begin
  1304.     if not InitInheritedComponent(Self, TCustomWebDispatcher) then
  1305.       raise EResNotFound.CreateFmt(SResNotFound, [ClassName]);
  1306.     if Assigned(OnCreate) then OnCreate(Self);
  1307.   end;
  1308. end;
  1309.  
  1310. { TWebApplication }
  1311.  
  1312. procedure DoneVCLApplication;
  1313. begin
  1314.   with Forms.Application do
  1315.   begin
  1316.     if Handle <> 0 then ShowOwnedPopups(Handle, False);
  1317.     Destroying;
  1318.     DestroyComponents;
  1319.   end;
  1320.   with Application do
  1321.   begin
  1322.     Destroying;
  1323.     DestroyComponents;
  1324.   end;
  1325. end;
  1326.  
  1327. procedure DLLExitProc(Reason: Integer); register;
  1328. begin
  1329.   if Reason = DLL_PROCESS_DETACH then DoneVCLApplication;
  1330. end;
  1331.  
  1332. constructor TWebApplication.Create(AOwner: TComponent);
  1333. begin
  1334.   inherited Create(AOwner);
  1335.   FCriticalSection := TCriticalSection.Create;
  1336.   FUniqueNumbers := TBits.Create;
  1337.   FActiveWebModules := TList.Create;
  1338.   FInactiveWebModules := TList.Create;
  1339.   FMaxConnections := 32;
  1340.   FCacheConnections := True;
  1341.   if IsLibrary then DLLProc := @DLLExitProc;
  1342. end;
  1343.  
  1344. destructor TWebApplication.Destroy;
  1345. begin
  1346.   Forms.Application.OnException := nil;
  1347.   FCriticalSection.Free;
  1348.   FUniqueNumbers.Free;
  1349.   FActiveWebModules.Free;
  1350.   FInactiveWebModules.Free;
  1351.   inherited Destroy;
  1352. end;
  1353.  
  1354. procedure TWebApplication.CreateForm(InstanceClass: TComponentClass;
  1355.   var Reference);
  1356. begin
  1357.   if FWebModuleClass = nil then
  1358.     FWebModuleClass := InstanceClass
  1359.   else raise Exception.Create(sOnlyOneDataModuleAllowed);
  1360. end;
  1361.  
  1362. function TWebApplication.ActivateWebModule: TDataModule;
  1363. begin
  1364.   FCriticalSection.Enter;
  1365.   try
  1366.     Result := nil;
  1367.     if (FMaxConnections > 0) and (FActiveWebModules.Count >= FMaxConnections) then
  1368.       raise Exception.Create(sTooManyActiveConnections);
  1369.     if FInactiveWebModules.Count > 0 then
  1370.     begin
  1371.       Result := FInactiveWebModules[0];
  1372.       FInactiveWebModules.Delete(0);
  1373.       FActiveWebModules.Add(Result);
  1374.     end else if FWebModuleClass <> nil then
  1375.     begin
  1376.       TComponent(Result) := FWebModuleClass.Create(Self);
  1377.       FActiveWebModules.Add(Result);
  1378.     end else raise Exception.Create(sNoDataModulesRegistered);
  1379.   finally
  1380.     FCriticalSection.Leave;
  1381.   end;
  1382. end;
  1383.  
  1384. procedure TWebApplication.DeactivateWebModule(DataModule: TDataModule);
  1385. begin
  1386.   FCriticalSection.Enter;
  1387.   try
  1388.     FActiveWebModules.Remove(DataModule);
  1389.     if FCacheConnections then
  1390.       FInactiveWebModules.Add(DataModule)
  1391.     else DataModule.Free;  
  1392.   finally
  1393.     FCriticalSection.Leave;
  1394.   end;
  1395. end;
  1396.  
  1397. procedure TWebApplication.DoHandleException(E: Exception);
  1398. begin
  1399. end;
  1400.  
  1401. function TWebApplication.GetActiveCount: Integer;
  1402. begin
  1403.   FCriticalSection.Enter;
  1404.   try
  1405.     Result := FActiveWebModules.Count;
  1406.   finally
  1407.     FCriticalSection.Leave;
  1408.   end;
  1409. end;
  1410.  
  1411. function TWebApplication.GetInactiveCount: Integer;
  1412. begin
  1413.   FCriticalSection.Enter;
  1414.   try
  1415.     Result := FInactiveWebModules.Count;
  1416.   finally
  1417.     FCriticalSection.Leave;
  1418.   end;
  1419. end;
  1420.  
  1421. function TWebApplication.HandleRequest(Request: TWebRequest;
  1422.   Response: TWebResponse): Boolean;
  1423. var
  1424.   DataModule: TDataModule;
  1425.   Dispatcher: TCustomWebDispatcher;
  1426.   I: Integer;
  1427. begin
  1428.   Result := False;
  1429.   DataModule := ActivateWebModule;
  1430.   if DataModule <> nil then
  1431.   try
  1432.     if DataModule is TCustomWebDispatcher then
  1433.       Dispatcher := TCustomWebDispatcher(DataModule)
  1434.     else with DataModule do
  1435.     begin
  1436.       Dispatcher := nil;
  1437.       for I := 0 to ComponentCount - 1 do
  1438.       begin
  1439.         if Components[I] is TCustomWebDispatcher then
  1440.         begin
  1441.           Dispatcher := TCustomWebDispatcher(Components[I]);
  1442.           Break;
  1443.         end;
  1444.       end;
  1445.     end;
  1446.     if Dispatcher <> nil then
  1447.     begin
  1448.       Result := Dispatcher.DispatchAction(Request, Response);
  1449.       if Result and not Response.Sent then
  1450.         Response.SendResponse;
  1451.     end else raise Exception.Create(sNoDispatcherComponent);
  1452.   finally
  1453.     DeactivateWebModule(DataModule);
  1454.   end;
  1455. end;
  1456.  
  1457. procedure TWebApplication.Initialize;
  1458. begin
  1459.   // This is a place holder
  1460. end;
  1461.  
  1462. procedure TWebApplication.OnExceptionHandler(Sender: TObject; E: Exception);
  1463. begin
  1464.   DoHandleException(E);
  1465. end;
  1466.  
  1467. procedure TWebApplication.SetCacheConnections(Value: Boolean);
  1468. var
  1469.   I: Integer;
  1470. begin
  1471.   if Value <> FCacheConnections then
  1472.   begin
  1473.     FCacheConnections := Value;
  1474.     if not Value then
  1475.     begin
  1476.       FCriticalSection.Enter;
  1477.       try
  1478.         for I := 0 to FInactiveWebModules.Count - 1 do
  1479.           TDataModule(FInactiveWebModules[I]).Free;
  1480.         FInactiveWebModules.Clear;  
  1481.       finally
  1482.         FCriticalSection.Leave;
  1483.       end;
  1484.     end;
  1485.   end;
  1486. end;
  1487.  
  1488. procedure TWebApplication.Run;
  1489. begin
  1490.   if not IsLibrary then AddExitProc(DoneVCLApplication);
  1491.   Forms.Application.OnException := OnExceptionHandler;
  1492. end;
  1493.  
  1494. function HTTPDecode(const AStr: String): String;
  1495. var
  1496.   Sp, Rp, Cp: PChar;
  1497. begin
  1498.   SetLength(Result, Length(AStr));
  1499.   Sp := PChar(AStr);
  1500.   Rp := PChar(Result);
  1501.   while Sp^ <> #0 do
  1502.   begin
  1503.     if not (Sp^ in ['+','%']) then
  1504.       Rp^ := Sp^
  1505.     else
  1506.       if Sp^ = '+' then
  1507.         Rp^ := ' '
  1508.       else
  1509.       begin
  1510.         inc(Sp);
  1511.         if Sp^ = '%' then
  1512.           Rp^ := '%'
  1513.         else
  1514.         begin
  1515.           Cp := Sp;
  1516.           Inc(Sp);
  1517.           Rp^ := Chr(StrToInt(Format('$%s%s',[Cp^, Sp^])));
  1518.         end;
  1519.       end;
  1520.     Inc(Rp);
  1521.     Inc(Sp);
  1522.   end;
  1523.   SetLength(Result, Rp - PChar(Result));
  1524. end;
  1525.  
  1526. function HTTPEncode(const AStr: String): String;
  1527. const
  1528.   NoConversion = ['A'..'Z','a'..'z','*','@','.','_','-'];
  1529. var
  1530.   Sp, Rp: PChar;
  1531. begin
  1532.   SetLength(Result, Length(AStr) * 3);
  1533.   Sp := PChar(AStr);
  1534.   Rp := PChar(Result);
  1535.   while Sp^ <> #0 do
  1536.   begin
  1537.     if Sp^ in NoConversion then
  1538.       Rp^ := Sp^
  1539.     else
  1540.       if Sp^ = ' ' then
  1541.         Rp^ := '+'
  1542.       else
  1543.       begin
  1544.         FormatBuf(Rp^, 3, '%%%.2x', 6, [Ord(Sp^)]);
  1545.         Inc(Rp,2);
  1546.       end;
  1547.     Inc(Rp);
  1548.     Inc(Sp);
  1549.   end;
  1550.   SetLength(Result, Rp - PChar(Result));
  1551. end;
  1552.  
  1553. const
  1554. // These strings are NOT to be resourced
  1555.  
  1556.   Months: array[1..12] of string = (
  1557.     'Jan', 'Feb', 'Mar', 'Apr',
  1558.     'May', 'Jun', 'Jul', 'Aug',
  1559.     'Sep', 'Oct', 'Nov', 'Dec');
  1560.  
  1561. function ParseDate(const DateStr: string): TDateTime;
  1562. var
  1563.   Month, Day, Year, Hour, Minute, Sec: Integer;
  1564.   Parser: TParser;
  1565.   StringStream: TStringStream;
  1566.  
  1567.   function GetMonth: Boolean;
  1568.   begin
  1569.     Month := 1;
  1570.     while not Parser.TokenSymbolIs(Months[Month]) and (Month < 13) do Inc(Month);
  1571.     Result := Month < 13;
  1572.   end;
  1573.  
  1574.   procedure GetTime;
  1575.   begin
  1576.     with Parser do
  1577.     begin
  1578.       Hour := TokenInt;
  1579.       NextToken;
  1580.       if Token = ':' then NextToken;
  1581.       Minute := TokenInt;
  1582.       NextToken;
  1583.       if Token = ':' then NextToken;
  1584.       Sec := TokenInt;
  1585.       NextToken;
  1586.     end;
  1587.   end;
  1588.  
  1589. begin
  1590.   StringStream := TStringStream.Create(DateStr);
  1591.   try
  1592.     Parser := TParser.Create(StringStream);
  1593.     with Parser do
  1594.     try
  1595.       NextToken;
  1596.       if Token = ':' then NextToken;
  1597.       NextToken;
  1598.       if Token = ',' then NextToken;
  1599.       if GetMonth then
  1600.       begin
  1601.         NextToken;
  1602.         Day := TokenInt;
  1603.         NextToken;
  1604.         GetTime;
  1605.         Year := TokenInt;
  1606.       end else
  1607.       begin
  1608.         Day := TokenInt;
  1609.         NextToken;
  1610.         if Token = '-' then NextToken;
  1611.         GetMonth;
  1612.         NextToken;
  1613.         if Token = '-' then NextToken;
  1614.         Year := TokenInt;
  1615.         if Year < 100 then Inc(Year, 1900);
  1616.         NextToken;
  1617.         GetTime;
  1618.       end;
  1619.       Result := EncodeDate(Year, Month, Day) + EncodeTime(Hour, Minute, Sec, 0);
  1620.     finally
  1621.       Free;
  1622.     end;
  1623.   finally
  1624.     StringStream.Free;
  1625.   end;
  1626. end;
  1627.  
  1628. procedure ExtractHTTPFields(Separators, WhiteSpace: TCharSet; Content: PChar;
  1629.   Strings: TStrings);
  1630. var
  1631.   Head, Tail: PChar;
  1632.   EOS, InQuote: Boolean;
  1633.   QuoteChar: Char;
  1634. begin
  1635.   if (Content = nil) or (Content^=#0) then Exit;
  1636.   Tail := Content;
  1637.   InQuote := False;
  1638.   QuoteChar := #0;
  1639.   repeat
  1640.     while Tail^ in WhiteSpace + [#13, #10] do Inc(Tail);
  1641.     Head := Tail;
  1642.     while True do
  1643.     begin
  1644.       while (InQuote and not (Tail^ in ['''', '"'])) or
  1645.         not (Tail^ in Separators + [#0, #13, #10]) do Inc(Tail);
  1646.       if Tail^ in ['''', '"'] then
  1647.       begin
  1648.         if (QuoteChar <> #0) and (QuoteChar = Tail^) then
  1649.           QuoteChar := #0
  1650.         else QuoteChar := Tail^;
  1651.         InQuote := QuoteChar <> #0;
  1652.         Inc(Tail);
  1653.       end else Break;
  1654.     end;
  1655.     EOS := Tail^ = #0;
  1656.     Tail^ := #0;
  1657.     if Head^ <> #0 then Strings.Add(HTTPDecode(Head));
  1658.     Inc(Tail);
  1659.   until EOS;
  1660. end;
  1661.  
  1662. function StatusString(StatusCode: Integer): string;
  1663. begin
  1664.   case StatusCode of
  1665.     100: Result := 'Continue';
  1666.     101: Result := 'Switching Protocols';
  1667.     200: Result := 'OK';
  1668.     201: Result := 'Created';
  1669.     202: Result := 'Accepted';
  1670.     203: Result := 'Non-Authoritative Information';
  1671.     204: Result := 'No Content';
  1672.     205: Result := 'Reset Content';
  1673.     206: Result := 'Partial Content';
  1674.     300: Result := 'Multiple Choices';
  1675.     301: Result := 'Moved Permanently';
  1676.     302: Result := 'Moved Temporarily';
  1677.     303: Result := 'See Other';
  1678.     304: Result := 'Not Modified';
  1679.     305: Result := 'Use Proxy';
  1680.     400: Result := 'Bad Request';
  1681.     401: Result := 'Unauthorized';
  1682.     402: Result := 'Payment Required';
  1683.     403: Result := 'Forbidden';
  1684.     404: Result := 'Not Found';
  1685.     405: Result := 'Method Not Allowed';
  1686.     406: Result := 'None Acceptable';
  1687.     407: Result := 'Proxy Authentication Required';
  1688.     408: Result := 'Request Timeout';
  1689.     409: Result := 'Conflict';
  1690.     410: Result := 'Gone';
  1691.     411: Result := 'Length Required';
  1692.     412: Result := 'Unless True';
  1693.     500: Result := 'Internal Server Error';
  1694.     501: Result := 'Not Implemented';
  1695.     502: Result := 'Bad Gateway';
  1696.     503: Result := 'Service Unavailable';
  1697.     504: Result := 'Gateway Timeout';
  1698.   else
  1699.     Result := '';
  1700.   end
  1701. end;
  1702.  
  1703. function TranslateChar(const Str: string; FromChar, ToChar: Char): string;
  1704. var
  1705.   I: Integer;
  1706. begin
  1707.   Result := Str;
  1708.   for I := 1 to Length(Result) do
  1709.     if Result[I] = FromChar then
  1710.       Result[I] := ToChar;
  1711. end;
  1712.  
  1713. function UnixPathToDosPath(const Path: string): string;
  1714. begin
  1715.   Result := TranslateChar(Path, '/', '\');
  1716. end;
  1717.  
  1718. function DosPathToUnixPath(const Path: string): string;
  1719. begin
  1720.   Result := TranslateChar(Path, '\', '/');
  1721. end;
  1722.  
  1723. end.
  1724.